home *** CD-ROM | disk | FTP | other *** search
/ The Programmer Disk / The Programmer Disk (Microforum).iso / xpro / pascal2 / pro6 / tdates.pas < prev    next >
Pascal/Delphi Source File  |  1986-08-04  |  7KB  |  228 lines
  1. { Full source within a sample program, containing the following 
  2. routines:
  3. n:=ymd2n(y,m,d); returns integer relative to Sep 19, 1989. The allowable
  4.                  date range is 1900 thru 2078.
  5. n2ymd(0,y,m,d); reverse of above. 0 results in 1989,9,19 for y,m,d.
  6. w:=n2dow(n) and w:=ymd2dow(y,m,d); returns 1=mon,2=tue,...7=sun
  7. dys:=nn2d(n1,n2) or dys:=dif(y1,m1,d1,y2,m2,d2); returns days between dates
  8. wkdys:=nn2w(n1,n2) or wkdys:=wdif(y1,m1,d1,y2,m2,d2); returns weekdays in range
  9. dys:=dim(y,m); returns days in the specified year/month.
  10. If ymdok(y,m,d) then...  returns true if date in range and all fields valid.
  11. s:=n2s(n) or n:=ymd2s(y,m,d); returns date as string in format:
  12.          "Saturday, the 24th of April, 1948"
  13. n:=newn(n,adj) or newymd(adj,y,m,d); adjusts given date forward or backward
  14. n:=n2w(n,5) or ymd2w(5,y,m,d); if not already friday, date is moved forward
  15. n:=n2pw(n,1) or ymd2pw(1,y,m,d); if not already monday, moved back in time
  16.  
  17. Take care that you don't exceed maxint in the routines where 2 days are given.
  18. In other words, dif(1910,1,1,2045,12,31) returns a negative number. As long as
  19. dates are less than 90 years apart, you're fine. If you don't like the range
  20. 1900..2078, then change then the BaseYear const to other than 1900. The ymd2n
  21. routine is derived from a julian date algortihm posted by Bob Brown in
  22. soft.eng/algortihm, of which he is a moderator.
  23.    If you change the BaseYear, you should also change the range checking in
  24. ymdok. You might also want to change the 'adjust' const to line up the dates
  25. for your new range. Lastly, you'll have to 'tweak' the 'n2dow' routine unless
  26. you happen to be lucky!
  27.    Any feedback/corrections/suggestions are appreciated, thanks! - Jim Keohane
  28. }
  29. Program tdates;
  30. var y,m,d,y2,m2,d2:integer;
  31. type anystring=string[255];
  32. const baseyear=1980; adjust=-100;
  33.  
  34. Function ymd2n(y,m,d:integer):integer;
  35. {returns day number relative to Sep 19, 1989}
  36. begin
  37.  ymd2n :=  367*(y-baseyear)
  38.            -7*(y+(m+9) div 12) div 4
  39.            -3*((y+(m-9) div 7) div 100+1) div 4
  40.            +275*m div 9
  41.            +d
  42.            +adjust
  43. end;
  44.  
  45. Function dim(y,m:integer):integer;
  46. {returns days in given month}
  47. begin
  48.  if m=12 then dim:=ymd2n(y+1,1,1)-ymd2n(y,m,1)
  49.  else dim:=ymd2n(y,m+1,1)-ymd2n(y,m,1)
  50. end;
  51.  
  52. Procedure n2ymd(n:integer;var y,m,d:integer);
  53. {given relative day, returns y,m,d}
  54. var i:integer;
  55. begin
  56.  y:=1989 + n div 365; m:=1; d:=1; {quick guess at year}
  57.  i:=ymd2n(y,m,d);
  58.  while i>n do
  59.   begin
  60.    y:=y-1;
  61.    i:=ymd2n(y,m,d)
  62.   end;
  63.  m:=1+(n-i) div 31; {quick guess at month}
  64.  while m>12 do begin y:=y+1; m:=m-12 end;
  65.  i:=ymd2n(y,m,d);
  66.  while dim(y,m) < n-i+1 do
  67.   begin
  68.    m:=m+1;
  69.    if m>12 then begin y:=y+1; m:=1 end;
  70.    i:=ymd2n(y,m,d)
  71.   end;
  72.  d:=1+n-i;
  73. end;
  74.  
  75. Function n2dow(n:integer):integer;
  76. {returns day of week 1=mon...6=sat,7=sun}
  77. begin
  78.  n2dow:=1+(n mod 7+8) mod 7;
  79. end;
  80.  
  81. Function ymd2dow(y,m,d:integer):integer;
  82. begin
  83.  ymd2dow:=n2dow(ymd2n(y,m,d))
  84. end;
  85.  
  86. Function ymdok(y,m,d:integer):boolean;
  87. {returns true if valid date}
  88. begin
  89.  if (y<1900) or (y>2078) or (m<1) or (m>12) or (d<1) then
  90.  ymdok:=false else ymdok:=d<=dim(y,m)
  91. end;
  92.  
  93. Function ymd2s(y,m,d:integer):anystring;
  94. {returns date string "Saturday, the 21st of April, 1979"}
  95. var s:anystring;
  96.     day,year,th:string[4];
  97. const days:array[1..7] of string[6]=
  98.            ('Mon','Tues','Wednes','Thurs','Fri','Satur','Sun');
  99.       months:array[1..12] of string[9]=
  100.              ('January','February','March','April','May','June',
  101.               'July','August','September','October','November','December');
  102. begin
  103. if d in [1,21,31] then th:='st' else
  104. if d in [2,22] then th:='nd' else
  105. if d in [3,23] then th:='rd' else th:='th';
  106. str(d,day);
  107. str(y,year);
  108. ymd2s:=days[ymd2dow(y,m,d)]+'day, the '+day+th+' of '+months[m]+', '+year
  109. end;
  110.  
  111. Function nn2d(n1,n2:integer):integer;
  112. {returns signed difference in days of n2-n1}
  113. begin
  114.  nn2d:=n2-n1
  115. end;
  116.  
  117. Function dif(y1,m1,d1,y2,m2,d2:integer):integer;
  118. {returns signed difference in days of ymd2-ymd1}
  119. begin
  120.  dif:=nn2d( ymd2n(y1,m1,d1) , ymd2n(y2,m2,d2) )
  121. end;
  122.  
  123. Function newn(oldn,adj:integer):integer;
  124. {returns oldn adjusted by adj days}
  125. begin
  126.  newn:=oldn+adj
  127. end;
  128.  
  129. Procedure newymd(adj:integer;var y,m,d:integer);
  130. {adjusts y,m,d by adj days}
  131. begin
  132.  n2ymd ( newn( ymd2n(y,m,d) , adj) , y, m, d )
  133. end;
  134.  
  135. Function n2w(n,w:integer):integer;
  136. {given desired weekday (w=1,2...7) returns n, moved forward, if neccessary}
  137. begin
  138.  n2w:=newn(n, (w-n2dow(n)+7) mod 7)
  139. end;
  140.  
  141. Function n2pw(n,w:integer):integer;
  142. {same as n2w, only movement is backwards, if neccessary}
  143. begin
  144.  n2pw:= newn( n, ((w-n2dow(n)+7) mod 7 - 7) mod 7)
  145. end;
  146.  
  147. Procedure ymd2w(w:integer;var y,m,d:integer);
  148. {if not desired weekday (w), moves ymd forward}
  149. begin
  150.  n2ymd ( n2w( ymd2n(y,m,d) , w ) , y, m, d )
  151. end;
  152.  
  153. Procedure ymd2pw(w:integer;var y,m,d:integer);
  154. {if not desired weekday (w), moves ymd backward}
  155. begin
  156.  n2ymd ( n2pw( ymd2n(y,m,d) , w ) , y, m, d )
  157. end;
  158.  
  159. Procedure MondaySince(var y,m,d:integer);
  160. {returns 1st monday since ymd}
  161. begin
  162.  ymd2w(1,y,m,d)
  163. end;
  164.  
  165. Procedure LatestFriday(var y,m,d:integer);
  166. {returns latest friday before (and including) ymd}
  167. begin
  168.  ymd2pw(5,y,m,d)
  169. end;
  170.  
  171. Function n2s(n:integer):anystring;
  172. var y,m,d:integer;
  173. begin
  174.  n2ymd(n,y,m,d);
  175.  n2s:=ymd2s(y,m,d)
  176. end;
  177.  
  178. Function nn2w(n1,n2:integer):integer;
  179. {returns the number of business days (signed) in the inclusive range}
  180. var i,j,k:integer;
  181. begin
  182.  if n1>n2 then nn2w:=-nn2w(n2,n1) else
  183.   begin
  184.    i:=n2dow(n1);
  185.    if i>5 then {sat or sun}
  186.     begin
  187.      n1:=n1+8-i;
  188.      i:=1 {make it a monday}
  189.     end;
  190.    j:=n2dow(n2);
  191.    if j>5 then {sat or sun}
  192.     begin
  193.      n2:=n2+5-j; {make it friday}
  194.      j:=5
  195.     end;
  196.    if n2<n1 then nn2w:=0 else
  197.     begin
  198.      k:=5 * ( (n2-n1) div 7 ) + j - i + 1;
  199.      if i>j then nn2w:=k+5 else nn2w:=k
  200.     end
  201.  end
  202. end;
  203.  
  204. Function wdif(y1,m1,d1,y2,m2,d2:integer):integer;
  205. {same as nn2w, but for ymd type dates}
  206. begin
  207.  wdif:=nn2w( ymd2n(y1,m1,d1) , ymd2n(y2,m2,d2) )
  208. end;
  209.  
  210. begin
  211. write('2 dates < y1 m1 d1 y2 m2 d2>...');readln(y,m,d,y2,m2,d2);
  212. if not ymdok(y,m,d) then writeln('1st date invalid ',y,' ',m,' ',d) else
  213. if not ymdok(y2,m2,d2) then writeln('2nd date invalid ',y2,' ',m2,' ',d2)
  214. else
  215. begin
  216. writeln('first date is ',ymd2s(y,m,d));
  217. writeln('   and has ',dim(y,m),' days in the given month');
  218. writeln('second date is ',ymd2s(y2,m2,d2));
  219. writeln('   and has ',dim(y2,m2),' days in the given month');
  220. writeln('There is a difference of ',dif(y,m,d,y2,m2,d2), ' day(s)');
  221. writeln('There are ',wdif(y,m,d,y2,m2,d2),' weekday(s) in the range');
  222. MondaySince(y,m,d);
  223. writeln('most recent monday since 1st is ',ymd2s(y,m,d));
  224. LatestFriday(y2,m2,d2);
  225. writeln('latest friday including 2nd is ',ymd2s(y2,m2,d2));
  226. end;
  227. end.
  228.